home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / Pocket Forth rel.5 / Text files / Reader < prev    next >
Encoding:
Text File  |  1991-07-19  |  11.6 KB  |  302 lines  |  [TEXT/EDIT]
  1. ( Reader application only ) forget task : task ;
  2.  
  3. ( ************************* )
  4. ( ****  W A R N I N G  **** )
  5. ( ************************* )
  6. (   This file seals off the input routines of Pocket Forth )
  7. ( creating a stand alone application.  The process is NOT )
  8. ( reversable! The copy of Pocket Forth this is loaded into )
  9. ( will no longer be usable as Pocket Forth.  Be sure you )
  10. ( understand what you are doing before modifying this )
  11. ( program.  Read it entirely.  You have been warned. )
  12.  
  13. (  Hit any key to continue.  Quit from menu to abort. )
  14.  
  15. key drop  ( last chance )
  16. 0 28 +md !  ( shut off screen echo )
  17. 3000 grow
  18.  
  19. : !FONT ( n -- ) >r ,$ A887 ;  ( _TextFont )
  20. : !FSIZE ( n -- ) >r ,$ A88A ;  ( _TextSize )
  21. : !FACE ( face -- ) >r ,$ A888 ; ( _TextFace )
  22. : SFONT ( -- ) 0 !font  12 !fsize ;  ( 12 point Chicago )
  23. : CLS ( -- ) 4 +md a>r ,$ A8A3  20 20 !pen ;  ( CLear Screen )
  24.  
  25. : EVEN ( n -- n' ) dup 2 mod + ;  ( round n up to an even number )
  26. : ," ( -- ) ( compile a quoted string from input stream )
  27.     34 word here c@ 1+ even allot ; IMMEDIATE
  28.  
  29. : WINDOW ( -- window.pointer ) 0 +md 2@ ;
  30.  
  31. ( menu support )
  32. : FMENUH ( -- dhandle ) 34 +md 2@ ;  ( File menu handle )
  33. create "OPEN" ," Open"  ( string data )
  34. create "CLOSE" ," Close"  ( string data )
  35.  
  36. : OIHANDLER ( -- addr ) ( the Open/Close item handler variable ) 
  37.     18 +md @ @ ; ( get pointer to File menu from menu list )
  38.  
  39. : WHIDE ( -- ) window 2>r ,$ A916 ;  ( _HideWindow )
  40. : WSHOW ( -- ) window 2>r ,$ A915 ;  ( _ShowWindow )
  41.  
  42. ( polygon handle storage )
  43. 2variable APOLY  ( aft button dpoly handle )
  44. 2variable FPOLY  ( fore button poly handle )
  45.  
  46. : ?PHIT ( h v poly -- flag ) ( true if h,v is in polyBBox )
  47.     0 >r  2@ dl@  2 0 d+  2swap 2>r  2>r ,$ A8AD r> ;  ( _PtInRect )
  48.  
  49. ( create polygons )
  50. : *POLY ( addr -- ) 0 0 2>r ,$ A8CB 2r> rot 2! ;  ( _OpenPoly )
  51. : *APOLY ( -- ) apoly *poly
  52.     5 225 !pen 20 210 -to 50 210 -to
  53.     50 240 -to 20 240 -to  5 225 -to  ,$ A8CC ;  ( _ClosePgon )
  54. : *FPOLY ( -- ) fpoly *poly
  55.     440 225 !pen 425 210 -to 390 210 -to
  56.     390 240 -to  425 240 -to 440 225 -to  ,$ A8CC ;  ( _ClosePgon )
  57.  
  58. ( print polygon )
  59. : .POLY ( addr -- ) 2@ 2>r ,$ A8C6 ;  ( _FramePoly )
  60. : .AARROW ( -- ) 015 230 !pen ." Back"  apoly .poly ;
  61. : .FARROW ( -- ) 396 230 !pen ." Next"  fpoly .poly ;
  62. : .ARROWS ( -- ) .aarrow .farrow ;
  63.       
  64. ( print PICT resources from this file )
  65. : GETPICT ( id -- dhandle ) 0 0 2>r  >r  ,$ A9BC  2r> ;  ( _GetPict )
  66. : DPICT ( rect id -- ) GetPict  ( -- pictures.handle )
  67.     2dup 2>r rot a>r ,$ A8F6 ;  ( _DrawPicture )
  68.  
  69. ( rect words )
  70. : RECT ( compile: -- ) ( run: -- addr ) variable 6 allot ;
  71. : !RECT ( t l b r rect -- ) >r  swap r 4 + 2!  swap r> 2! ;
  72. : @RECT ( rect -- t l b r ) dup 2@ swap  rot 4 + 2@ swap ;
  73. : ROFFSET ( h v rect -- ) a>r 2>r ,$ A8A8 ;  ( _OffsetRect )
  74. : RINSET ( h v rect -- ) a>r 2>r ,$ A8A9 ;  ( _InsetRect )
  75. : ?IN ( h v rect -- flag ) ( true if h,v is in rect at addr )
  76.     0 >r  rot rot 2>r  a>r  ,$ A8AD r> ;  ( _PtInRect )
  77. : ?EMPTY ( rect -- flag ) 0 >r a>r ,$ A8AE r> ;  ( _EmptyRect )
  78. : RERASE ( rect -- ) a>r ,$ A8A3 ;  ( _EraseRect )
  79.  
  80. ( rects for pictures )
  81. rect PRECT  15 48 212 405 prect !rect  ( title picture rect )
  82. rect SRECT  192 222 221 370 srect !rect  ( signature rect )
  83.  
  84. : SCR ( -- ) @pen swap drop 16 + 50 swap !pen ;  ( special cr )
  85.  
  86. ( P1 - P? are page drawing routines.  They have no stack effect.)
  87. : P1  cls  prect 4000 dpict
  88.     23 30 !pen ." NEW!"  .farrow ;
  89.  
  90. : P2  cls scr
  91.     ."       Its FAST, its FUN and its FREE!" scr scr
  92.     ."    Pocket Forth, release 5 is an ideal language" scr
  93.     ."  for experimenting with the Macintosh toolbox." cr scr
  94.     ."    For information, etc., send electronic mail to me" scr
  95.     ."  on CompuServe at [70566,1474]," scr
  96.     ."     Bitnet at “heilman@pc” or" scr
  97.     ."     U.S. mail to 85066-8345." scr
  98.     ."  I answer all mail and your input is welcome."
  99.     srect 4001 dpict  ( draw signature picture )
  100.     .arrows ;
  101.  
  102. : P3  cls scr
  103.     ."   Pocket Forth is a small compiling interpreter that" scr
  104.     ." comes in application and DA versions." cr scr
  105.     ."   The code produced by Pocket Forth is both compact" scr
  106.     ." and fast.  Since Pocket Forth is a Forth language" scr
  107.     ." system that produces true machine code, you have" scr
  108.     ." complete control over (and responsibility for)" scr
  109.     ." your program." cr scr
  110.     ."   The current release is System 7 friendly and will" scr
  111.     ." run on any Macintosh/System combination.  As with" scr
  112.     ." all earlier releases, Pocket Forth is free."
  113.     .arrows ;
  114.  
  115. : P4  cls scr
  116.     ." Get started and check out Pocket Forth's speed:" cr scr
  117.     ." 1) Place a copy of Pocket Forth and the text file" scr
  118.     ."     called Sieve on a startup disk, not in any folder." scr
  119.     ." 2) Double click on Pocket Forth's icon." scr
  120.     ." 3) When the window says “ok” type:" scr
  121.     ."             --> sieve" scr
  122.     ."     with a 'return' at the end." scr
  123.     ." 4) Watch the words scroll by, " 2 8 + !face  ( outline italic )
  124.     ." hold on!" 0 !face
  125.     .arrows ;
  126.  
  127. : P5  cls scr
  128.     ." Pocket Forth release 5 contains:" scr
  129.     ."  • PocketForth0.5, the application" scr
  130.     ."  • PocketDA, a Font/DA Mover file" scr
  131.     ."     containing: PocketForth1.5, a System 7 DA" scr
  132.     ."  • The Pocket Forth Manual (an MS Word file)" scr
  133.     ."  • The Glossary of Pocket Forth words (an MS Word file)" scr
  134.     ."  • Complete source code and What's New?" cr scr
  135.     ."        Example Text Files:" scr
  136.     ."  • Sieve:    The Sieve of Erastothanes benchmark" scr
  137.     ."  • Reader: Create this stand alone application" scr
  138.     ."  • Extras:  Files, grafics, math, text editing and more…"
  139.     .arrows ;
  140.  
  141. : P6  cls scr
  142.     ." Major changes since release 4:" cr scr
  143.     ."  • Multitasking and background operation." scr
  144.     ."  • High level events can be accepted." scr
  145.     ."  • All code is 32 bit clean." scr
  146.     ."  • Improved menus include Open command." scr
  147.     ."  • The manual has been updated." scr
  148.     ."  • Balloon help for System 7 users." scr
  149.     ."  • Color icons and pictures are included." scr
  150.     .arrows ;
  151.  
  152. : P7  cls cr scr
  153.     ."   Print and read the Manual and the Glossary." cr scr
  154.     ."   The Manual is a 23 page MS Word document" scr
  155.     ." formatted for a laser printer." cr scr
  156.     ."   It is suitable for use as a reference to Pocket Forth" scr
  157.     ." for old hats" 2 !face  ." and" 0 !face  ( italic )
  158.     ."  as a supplement to Brodie's" scr 4 !face  ( underline )
  159.     ." Starting FORTH" 0 !face ."  for new Forthers."
  160.     .arrows ;
  161.  
  162. : P8  cls cr scr
  163.     ."   The Glossary is an 11 page MS Word document." cr scr
  164.     ."   The Glossary is a complete list of all of the words" scr
  165.     ." in the Pocket Forth dictionary.  Stack effects," scr
  166.     ." pronounciation and common usage are shown."
  167.     .arrows ;
  168.  
  169. : P9  cls scr
  170.     ."   Source code, printed documentation, all of the" scr
  171.     ." files, the Bezier DA kit and other examples are" scr
  172.     ." available from the author." cr scr
  173.     ."   The Pocket Forth source is over 100K of MDS" scr
  174.     ." assembly code.  Instructions are included." cr scr
  175.     ."   The Bezier kit includes Bezier's source code," scr
  176.     ." additional resources, and assembly instructions," scr
  177.     ." as well as the completed DA and manual." cr scr
  178.     ."   Contact the author for any of these items."
  179.     .aarrow ;
  180.  
  181. variable PWHICH  0 pwhich !  ( which page to be drawn )
  182. create PLIST  ( ordered list of routines or "pages" )
  183.     ' p1 ,  ' p2 ,  ' p3 ,  ' p4 ,
  184.     ' p5 ,  ' p6 ,  ' p7 ,  ' p8 ,  ' p9 ,
  185.  
  186. ( menu, button and event handlers )
  187. : DOCLOSE ( -- ) ( the Close handler for the File menu )
  188.     whide  ( hide the window )
  189.     fmenuh 2>r  1 >r  "open" a>r  ,$ A947  ( _SetItem )
  190.     [ ' null literal  here 2 - ]  ( leave address for a forward reference )
  191.     oihandler ! ;
  192.  
  193. : DOOPEN ( -- ) ( the Open handler for the File menu )
  194.     wshow  ( hide the window )
  195.     fmenuh 2>r  1 >r  "close" a>r  ,$ A947  ( _SetItem )
  196.     [ ' doclose literal ] oihandler ! ;
  197. ' doopen swap !  ( resolve forward reference )
  198.  
  199. : DOUP  pwhich @ 2* plist + @ execute ;  ( draw the pwhichth page )
  200. : DOAFT  pwhich @ 1 - 0 max pwhich ! doup ;  ( decrement pwhich )
  201. : DOFOR  pwhich @ 1+ 8 min pwhich ! doup ;  ( increment pwhich )
  202. : DOBUTT  ( -- ) ( button handler )
  203.     @mouse apoly ?phit IF apoly 2@ 2>r ,$ A8C9 doaft ELSE
  204.       @mouse fpoly ?phit IF fpoly 2@ 2>r ,$ A8C9  dofor 
  205.     THEN  THEN ;
  206.  
  207. ( create and destroy pictures )
  208. : PICTURE ( rect -- dhandle ) ( open a picture )
  209.     0 0 2>r  a>r  ,$ A8F3 2r> ;  ( _OpenPicture )
  210. : PCLOSE ,$ A8F4 ; macro  ( _ClosePicture )
  211. : PKILL ( addr -- ) 2@ 2>r ,$ A8F5 ; ( _KillPicture at addr )
  212. : PDRAW ( rect dhandle -- ) ( draw a picture in rect )
  213.     2>r a>r ,$ A8F6 ;  ( _DrawPicture )
  214.  
  215. rect BRECT  ( the bird's rect )
  216. rect OBRECT  ( old brect )
  217. 2variable B1PICT  ( hold b1's pict handle )
  218. 2variable B2PICT  ( hold b2's pict handle )
  219. 2variable B3PICT  ( hold b3's pict handle )
  220.  
  221. ( draw the three bird positions )
  222. : .B1  2 0 !pen 6 0 -to 12 6 -to 18 0 -to 22 0 -to ;
  223. : .B2  0 6 !pen 24 6 -to ;
  224. : .B3  2 12 !pen 6 12 -to 12 6 -to 18 12 -to 22 12 -to ;
  225.  
  226. : BNEW  brect picture .b1 pclose b1pict 2!
  227.     brect picture .b2 pclose b2pict 2!
  228.     brect picture .b3 pclose b3pict 2! ;
  229. : BKILL  b1pict pkill b2pict pkill b2pict pkill ;
  230.  
  231. : B1 brect b1pict 2@ pdraw ;
  232. : B2 brect b2pict 2@ pdraw ;
  233. : B3 brect b3pict 2@ pdraw ;
  234. create .BS  ' b1 ,  ' b2 ,  ' b3 ,  ( bird draw array )
  235. variable BTHIS  0 bthis !  ( offset to the current routine )
  236.  
  237. : XLATE 3 -1 brect roffset ;  ( translate brect )
  238. : INSET 1 1 brect rinset ;  ( shrink brect )
  239.  
  240. : ANIMATE ( -- ) ( draw the current bird, etc. )
  241.     brect ?empty IF  ( if the bird has shrunk to oblivion  ... )
  242.       48 291 60 309 brect !rect  THEN  ( ... restore its origonal size )
  243.     obrect rerase  ( erase the old bird )
  244.     brect @rect obrect !rect  ( set the old bird to the current bird )
  245.     0 -1 obrect rinset  ( expand the old birds rect )
  246.     bthis @  ( get the current bird offset )
  247.     dup .bs + @  execute  ( execute the address of the draw bird routine )
  248.     4 < IF  ( if its bird 1 or 2 )
  249.       2 bthis +!  xlate  ( increment bird offset and move the bird's rect )
  250.     ELSE  ( its bird 3 )
  251.       0 bthis !  xlate inset  ( set bird 1, move and shrink bird's rect )
  252.       2 >r ,$ A889  ( SrcXor _TextMode )
  253.       23 30 !pen ." NEW!   IMPROVED!"  ( flip the title )
  254.     THEN ;
  255.  
  256. variable TLAST  0 tlast !  ( timer )
  257. 10 constant DELAY
  258. : TICKS ( -- n ) 364 0 l@ ;
  259. : ?TIME ( -- flags ) ( true if 1/delay seconds has elapsed )
  260.     ticks tlast @ - abs delay > ;
  261. : DOIDLE
  262.     pwhich @ 0= IF  ( if its the title page )
  263.       ?time IF ticks tlast ! animate
  264.     THEN  THEN ;
  265.  
  266. : DOKEYS ( keycode -- )
  267.     dup 49 = IF 0 pwhich ! doup THEN  ( if it's 1 )
  268.     dup 50 = IF doaft THEN  ( if it's 2 )
  269.     dup 51 = IF dofor THEN  ( if it's 3 )
  270.     dup 52 = IF 7 pwhich ! doup THEN  ( if it's 4 )
  271.     0 -20 !pen  drop ;
  272.  
  273. : STOP  bkill ,$ A9F4 ; ( _ExitToShell )
  274. : START *apoly *fpoly  sfont
  275.     0 0 14 28 brect !rect  bnew
  276.     0 0 0 0 brect !rect
  277.     0 0 0 0 obrect !rect 
  278.     begin key dokeys again ;  ( event loop  appl. only )
  279.  
  280. 450 250    8 +md 2!  ( set window size )
  281.  
  282. ( set event/message handlers )
  283. ' doup    14 +md !  ( set update handler )
  284. ' dobutt  16 +md !  ( set button handler )
  285. ' doidle  20 +md !  ( set idle handler )
  286. ' start   26 +md !  ( set open handler )
  287. ' doclose 22 +md !  ( set close handler )
  288.  
  289. ( set menu handlers )
  290. ' beep  18 +md @  ( get pointer to menu list )
  291.         2+ @  ( get pointer to Edit menu from menu list )
  292.         8 + !  ( set paste handler to beep )
  293. ' doclose  oihandler !  ( set Open/Close menu handler )
  294. ' stop  oihandler 4 + !  ( set quit handler )
  295.  
  296. save : bye ,$ A9F4 ; bye  ( save and quit )
  297.  
  298. ( The ReadMe application also has been doctored with ResEdit )
  299. ( to smooth it out.  The About DITL, Edit MENU, File MENU, )
  300. ( WIND, ICN#, and SIZE resources need to be changed.  The )
  301. ( PICTs need to be added. )
  302.